home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Extra Heft 12
/
Extra Heft12.bin
/
input64
/
05_86.d64
/
editor .lsp
< prev
next >
Wrap
Text File
|
1995-08-17
|
4KB
|
126 lines
(NX EXPR (LAMBDA NIL (COND ((ATOM (
CDR CLU))) (T (SETQ CLU (CDR CLU)) (
SETQ CL (CAR CLU))))))
(FIND EXPR (LAMBDA (L I X W) (COND ((
ATOM L) NIL) ((MEMBER I (CAR L)) (
LIST X)) ((SETQ W (FIND (CAR L) I 1))
(CONS X W)) (T (FIND (CDR L) I (ADD1
X))))))
(FI FEXPR (NLAMBDA (I) (MAPC (QUOTE G)
(FIND CL I 1 NIL)) (P)))
(B FEXPR (NLAMBDA L (RPLACA CLU (SETQ
CL (CONC L (CAR CLU)))) (BACK)) VALUE
(A B (C D E) F G))
(: FEXPR (NLAMBDA (L) (RPLACA CLU (
SETQ CL L))))
(LO EXPR (LAMBDA (X Y Z) (SETQ Z (NTH
CL (H X))) (SETQ Y (NTH CL (H (SUB1 X)
))) (COND ((CONSP (CAR Z)) (RPLACD Y (
CAR Z))))))
(LI EXPR (LAMBDA (X) (BI X -1)))
(R FEXPR (NLAMBDA (X Y) (REPL X Y CL))
)
(REPL EXPR (LAMBDA (X Y L) (COND ((
ATOM L) NIL) ((EQUAL (CAR L) X) (
RPLACA L Y) (REPL X Y (CDR L))) ((
EQUAL (CDR L) X) (RPLACD L Y)) (T (
REPL X Y (CAR L)) (REPL X Y (CDR L))))
))
(RO EXPR (LAMBDA (X Y) (COND ((NULL Y)
(SETQ Y (LENGTH CL)))) (SETQ X (NTH
CL (H X))) (SETQ Y (NTH CL (H Y))) (
RPLACA X (CONC (CAR X) (CDR X))) (
RPLACD X (CDR Y)) (RPLACD Y NIL)))
(BO EXPR (LAMBDA (X) (SETQ X (NTH CL (
H X))) (SETQ Y (CONC (CAR X) (CDR X)))
(RPLACA X (CAR Y)) (RPLACD X (CDR Y))
))
(BI EXPR (LAMBDA (X Y) (COND ((NULL Y)
(SETQ Y X))) (SETQ X (NTH CL (H X)))
(SETQ Y (NTH CL (H Y))) (SETQ Z (CDR
Y)) (RPLACD Y NIL) (RPLACA X (CONS (
CAR X) (CDR X))) (RPLACD X Z)))
(RI EXPR (LAMBDA (X Y) (SETQ X (NTH
CL (H X))) (SETQ Y (NTH (CAR X) (H Y))
) (SETQ Z (CDR X)) (RPLACD X (CDR Y))
(CONC (CDR Y) Z) (RPLACD Y NIL)))
(EXPT EXPR (LAMBDA (X Y) (COND ((EQ Y
0) 1) (T (TIMES X (EXPT X (SUB1 Y)))))
))
(E FEXPR (NLAMBDA (L) (PRINT (EVAL L))
) VALUE (NLAMBDA (L) (PRINT (EVAL L)))
)
(_ EXPR (LAMBDA NIL (SETQ CLU (LAST
TR)) (SETQ TR (LIST CLU)) (SETQ CL (
CAR CLU))))
(N FEXPR (NLAMBDA L (CONC CL L)))
(A FEXPR (NLAMBDA L (RPLACD CLU (CONC
L (CDR CLU))) (BACK)) VALUE (NLAMBDA
L (RPLACD CLU (CONC L (CDR CLU))) (
BACK)))
(CONC EXPR (LAMBDA (L1 L2) (COND ((
ATOM L1) L2) ((ATOM L2) L1) (T (NCONC
L1 L2)))))
(DEL EXPR (LAMBDA (X L) (SETQ X (H X))
(COND ((ATOM CL) CL) ((ZEROP X) (
RPLACA CLU (SETQ CL (CONC L CL)))) ((
EQ X 1) (RPLACA CLU (SETQ CL (CONC L (
CDR CL))))) (T (RPLACD (NTH CL (SUB1
X)) (CONC L (NTH CL (ADD1 X))))))))
(UNDO EXPR (LAMBDA NIL (SETQ LIS (
COPY OLD)) (SETQ CLU (LIST LIS)) (
SETQ TR (LIST CLU)) (SETQ CL (CAR CLU)
)))
(OUT EXPR (LAMBDA NIL (SAVE 8
"@0:EDITOR.LSP" EDFNS)))
(ADD FEXPR (NLAMBDA L (COND ((ATOM L)
EDFNS) (T (SETQ EDFNS (CONS (CAR L)
EDFNS)) (APPLY (QUOTE ADD) (CDR L)))))
)
(P@ EXPR (LAMBDA NIL (PP CL)))
(BACK EXPR (LAMBDA NIL (COND ((ATOM (
CDR TR)) CL) (T (SETQ CLU (CAR TR)) (
SETQ TR (CDR TR)) (SETQ CL (CAR CLU)))
)))
(G EXPR (LAMBDA (X) (SETQ X (H X)) (
COND ((ZEROP X) (BACK)) ((GREATERP X (
LENGTH CL)) CL) (T (SETQ TR (CONS CLU
TR)) (SETQ CLU (NTH CL X)) (SETQ CL (
CAR CLU))))))
(P EXPR (LAMBDA NIL (PRINT (P& CL)))
VALUE (LAMBDA NIL (PRINT (P& CL))))
(P& EXPR (LAMBDA (L) (COND ((ATOM L)
L) (T (CONS (P& (CAR L)) (MAPCAR (
QUOTE (LAMBDA (X) (COND ((ATOM X) X) (
T (QUOTE &))))) (CDR L)))))))
(H EXPR (LAMBDA (X) (COND ((MINUSP X)
(SETQ X (ABS (PLUS 1 X (LENGTH CL)))))
) (COND ((GREATERP X (LENGTH CL)) (
LENGTH CL)) (T X))))
(EDFNS VALUE (NX FIND FI B : LO LI R
REPL RO BO BI RI EXPT E _ N A CONC
DEL UNDO OUT ADD P@ BACK G P P& H
EDFNS EDIT EDITF EDITV EDITP))
(EDIT EXPR (LAMBDA (L) (PROG (OLD TR
CL CLU E X LIS) (SETQ OLD L) (SETQ
LIS (COPY L)) (SETQ CLU (LIST LIS)) (
SETQ TR (LIST CLU)) (SETQ CL (CAR CLU)
) (P) LOOP1 (MSG "*ED*: ") (SETQ E (
READL)) LOOP2 (COND ((ATOM E) (GO
LOOP1))) (SETQ X (CAR E)) (COND ((
NUMBERP X) (G X)) ((EQ X (QUOTE OK)) (
RETURN (CAR (LAST TR)))) ((EQ X (
QUOTE PP)) (PP CL)) ((ATOM X) (EVAL (
LIST X))) ((NUMBERP (CAR X)) (DEL (
CAR X) (CDR X))) (T (EVAL X))) (SETQ
E (CDR E)) (GO LOOP2))))
(EDITF FEXPR (NLAMBDA (F L) (COND ((
SETQ L (APPLY (QUOTE GETDEF) (LIST F))
) (EVAL (CONS (CAR L) (CONS (CADR L) (
EDIT (CDDR L)))))))))
(EDITV FEXPR (NLAMBDA (F) (SET F (
EDIT (EVAL F)))))
(EDITP FEXPR (NLAMBDA (A P) (PUTPROP
A P (EDIT (GETPROP A P)))))
NIL